home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / CAD / PKEY11_1.ARJ / COL.LSP < prev    next >
Text File  |  1992-03-14  |  2KB  |  57 lines
  1. ;Add Columns and Grid Patterns
  2. ;
  3. ;                     ********Patrick J. McKee, author********
  4. ;                       ****Copyright 1992, Power Key tm****
  5. ;
  6. ;
  7. (defun dtr (a1)
  8. (* pi (/ a1 180.0)))
  9. (setq oer *error* *error* err)
  10. (pre)
  11. (If(= gx nil)(setq *gx 120))
  12. (setq gx(getdist(strcat "X -  grid spacing <"(rtos *gx)">: ")))
  13. (if(= gx nil)(setq gx *gx)(setq *gx gx))
  14. (if(= gy nil)(setq *gy 120))
  15. (setq gy(getdist(strcat "Y -  grid spacing <"(rtos *gy)">: ")))
  16. (if(= gy nil)(setq gy *gy)(setq *gy gy))
  17. (setq xa(atof(getstring "\nX - column size. :")))
  18. (setq ya(atof(getstring(strcat "\nY - column size. <"(rtos xa)"):"))))
  19. (if (= ya 0.0)(setq ya xa))
  20. (if (= *cb nil)(setq *cb "S")
  21. (setq cb *cb))
  22. (setq colblk(getstring(strcat"\n(C)ircle. (S)quare. :< ")(prompt *cb)(prompt "\ >")
  23. (princ)))
  24. (if(= colblk "")(setq colblk *cb)(setq *cb colblk))
  25. (If(or(= colblk "s")(= colblk "s"))(setq colblk "colsqr"))
  26. (if(or(= colblk "c")(= colblk "c"))(setq colblk "colcir"))
  27. (setq p1(getpoint "Pick lower left column grid limit. : "))
  28. (Setq p0(getpoint "Pick upper right column grid limit. : "))
  29. (Setq c(distance p1 p0))
  30. (setq a1(angle p1 p0))
  31. (setq b(* c(sin a1)))
  32. (setq a(* c(cos a1)))
  33. (setq aa(-(fix(/ a gx))1))
  34. (if(= aa 0)(setq aa(+ aa 1)))
  35. (setq d(/(- a(* aa gx))2))
  36. (setq p2(list(+(car p1)d)(cadr p1)))
  37. (setq p3(list(car p2)(+(cadr p2)b)))
  38. (setq bb(-(fix(/ b gy))1))
  39. (if(= bb 0)(setq bb(+ bb 1)))
  40. (setq db(/(- b(* bb gy))2))
  41. (setq p4(list(car p1)(+(cadr p1)db)))
  42. (setq p5(list(+(car p4)a)(cadr p4)))
  43. (setq ip(list(+(car p4)d)(cadr p4)))
  44. (command"layer""S""cg""")
  45. (command "line" p2 p3 "")
  46. (command "array" "l" "" "r" "1"(+ aa 1)gx)
  47. (command "line" p4 p5 "")
  48. (command "array" "l" "" "r"(+ bb 1)"1" gy)
  49. (setq cb1(strcat "\\kesym1\\" colblk))
  50. (command"layer" "s" "ew" "")
  51. (command"insert" cb1 ip xa ya "0")
  52. (command"array" "l" "" "r""1"(+ aa 1)gx)
  53. (setq a1 (angle p2 p3))
  54. (setq wd (/(distance p1 p2)2))
  55. (setq wp (polar p5 (+ a1 (dtr 0)) wd))
  56. (command "array" "w" p1 wp "r" p4 "" "r"(+ bb 1)"1" gy)
  57. (post)(setq p0 nil a nil aa nil b nil p1 nil p2 nil p3 nil bb nil db nil p4 nil p5 nil ip nil cb1 nil a1 nil wd nil wp nil)(princ)